home *** CD-ROM | disk | FTP | other *** search
/ Magnum One / Magnum One (Mid-American Digital) (Disc Manufacturing).iso / d13 / oct90.arc / TRANFL.LSP < prev   
Encoding:
Text File  |  1990-11-01  |  4.7 KB  |  140 lines
  1. ; TRANFL.LSP   [Article Figure 1]   (c)1990, Gary Lewis
  2.  
  3. ; ********************** TRANFL.LSP ***************************
  4. ; Copyright (c) Gary Lewis 1990
  5. ;______________________________________________________________
  6. (defun TRAN_INPUT ()
  7.    (setq
  8.      C (getpoint "\nEnter center point of circle X,Y,Z: ")
  9.      R (getreal  "\nEnter radius of circle: "))
  10.    (command "CIRCLE" C R )
  11.    (prompt "\nEnter 4 counterclockwise points... ")
  12.    (setq
  13.      P1 (getpoint "\nEnter 1st point X,Y,Z: ")
  14.      P2 (getpoint "\nEnter 2nd point X,Y,Z: ")
  15.      P3 (getpoint "\nEnter 3rd point X,Y,Z: ")
  16.      P4 (getpoint "\nEnter 4th point X,Y,Z: "))
  17. )
  18. ;______________________________________________________________
  19. (defun TRAN_DRAW () ;draw transition
  20.   (setq PCX (car C) PCY (cadr C) PCZ (caddr C)
  21.     V1 (- (angle P1 P2) (/ PI 2))
  22.     V2 (- (angle P2 P3) (/ PI 2))
  23.     V3 (- (angle P3 P4) (/ PI 2))
  24.     V4 (- (angle P4 P1) (/ PI 2))
  25.     C1 (polar C V1 R) C2 (polar C V2 R)
  26.     C3 (polar C V3 R) C4 (polar C V4 R)
  27.     A1 (- PI (- (angle P1 P4) (angle P1 P2)))
  28.     A2 (- PI (- (angle P2 P1) (angle P2 P3)))
  29.     A3 (- PI (- (angle P2 P3) (angle P4 P3)))
  30.     A4 (- PI (- (angle P3 P4) (angle P1 P4))))
  31.   (command "LINE" P1 P2 P3 P4 P1 C1 P2 C2 P3 C3 P4 C4 P1 ^C)
  32. )
  33. ;______________________________________________________________
  34. (defun FLAT () ;true length
  35.   (setq L12  (distance P1 P2) L23  (distance P2 P3)
  36.     L34  (distance P3 P4) L41  (distance P4 P1)
  37.     LC11 (distance C1 P1) LC12 (distance C1 P2)
  38.     LC22 (distance C2 P2) LC23 (distance C2 P3)
  39.     LC33 (distance C3 P3) LC34 (distance C3 P4)
  40.     LC44 (distance C4 P4) LC41 (distance C4 P1))
  41. )
  42. ;______________________________________________________________
  43. (defun QXRAD ()   ;find swept rad for 4 points
  44.   (setq PQZ (caddr P1) PG P1 S A1)
  45.   (Q_RAD)
  46.   (setq Q1 QG CON1 CONG E1 EG PQZ (caddr P2) PG P2 S A2)
  47.   (Q_RAD)
  48.   (setq Q2 QG CON2 CONG E2 EG PQZ (caddr P3) PG P3 S A3)
  49.   (Q_RAD)
  50.   (setq Q3 QG CON3 CONG E3 EG PQZ (caddr P4) PG P4 S A4)
  51.   (Q_RAD)
  52.   (setq Q4 QG CON4 CONG E4 EG)
  53. )
  54. ;______________________________________________________________
  55. (defun Q_RAD ()  ;swept rad
  56.   (setq Z (abs(- PCZ PQZ)) K (list PCX PCY PQZ)
  57.     A (distance PG K )     B (- A R)
  58.     X (abs B)              Y 0.0000001
  59.   )
  60.  (if (< X Y)              ;to prevent division by zero
  61.    (progn
  62.       (setq QG 1E+10)     ;QG would approach infinity
  63.       (setq EG (* S R))   ;arc would become straight line
  64.       (setq CONG -1)
  65.    )
  66.    (progn
  67.      (if (> B 0)
  68.        (progn
  69.          (setq D1 (* (/ A (abs B)) Z))
  70.          (setq QG (sqrt (+(expt R 2) (expt (- D1 Z) 2))))
  71.          (setq CONG 1)
  72.        )
  73.        (progn
  74.          (setq D2(/ (* (+ A (abs B)) Z) B))
  75.          (setq QG (sqrt (+ (expt R 2) (expt D2 2))))
  76.          (setq CONG -1)
  77.        )
  78.      )
  79.      (setq EG (* (sin (/ (* S R) 2. QG)) 2. QG)) ;chord length
  80.    )
  81.  )
  82. )
  83. ;______________________________________________________________
  84. (defun TRI_CAL () ;cosine law
  85.   (setq ANG-1 (angle G2 G1)
  86.     COSA (/ (- (+ (expt BG 2)(expt CG 2))(expt AG 2)) 2. BG CG)
  87.     ANG (+ (abs(atan(/(sqrt (- 1. (expt COSA 2)))COSA))) ANG-1)
  88.     G3 (polar G2 ANG CG))
  89. )
  90. ;______________________________________________________________
  91. (defun DFLAT ()
  92.   (setq G1 (getpoint "\nPick start point for flat layout ")
  93.         G2 (list (+ (car G1) L12) (cadr G1))
  94.         F1 G1 F2 G2 BG L12 CG LC12 AG LC11)
  95.   (TRI_CAL)
  96.   (setq FC1 G3 G1 FC1  AG E2   CG LC22 BG LC12)
  97.   (TRI_CAL)
  98.   (setq FC2 G3 G1 G3   BG LC22 AG LC23 CG L23)
  99.   (TRI_CAL)
  100.   (setq F3  G3 G2 G3   CG LC33 AG E3   BG LC23)
  101.   (TRI_CAL)
  102.   (setq FC3 G3 AG LC34 CG L34  G1 G3   BG LC33)
  103.   (TRI_CAL)
  104.   (setq F4  G3 G2 G3   AG E4   BG LC34 CG LC44)
  105.   (TRI_CAL)
  106.   (setq FC4 G3 G1 G3   AG LC41 BG LC44 CG L41)
  107.   (TRI_CAL)
  108.   (setq F5  G3 G2 G3   AG E1   BG LC41 CG LC11)
  109.   (TRI_CAL)
  110.   (setq FC5 G3)
  111.   (command "LINE" F5 F4 F3 F2 F1 FC1 F2 FC2 F3 FC3 F4 FC4
  112.     F5 FC5 ^C)
  113.   (setq AP1 FC2 AP2 FC1 AR Q2 CON CON2)
  114.   (ARCG)
  115.   (setq AP1 FC3 AP2 FC2 AR Q3 CON CON3)
  116.   (ARCG)
  117.   (setq AP1 FC4 AP2 FC3 AR Q4 CON CON4)
  118.   (ARCG)
  119.   (setq AP1 FC5 AP2 FC4 AR Q1 CON CON1)
  120.   (ARCG)
  121. )
  122. ;______________________________________________________________
  123. (defun ARCG ()    ;draw arcs concave or convex
  124.   (if (> CON 0)
  125.       (command "ARC" AP1 "E" AP2 "R" AR )
  126.       (command "ARC" AP2 "E" AP1 "R" AR )
  127.   )
  128. )
  129. ;______________________________________________________________
  130. (defun C:TRAN ()  ;main program
  131.    (TRAN_INPUT)
  132.    (setq SBLIP (getvar "BLIPMODE") SCMDE (getvar "CMDECHO"))
  133.    (setvar "BLIPMODE" 0) (setvar "CMDECHO" 1)
  134.    (TRAN_DRAW)
  135.    (setvar "BLIPMODE" SBLIP) (setvar "CMDECHO" SCMDE)
  136.    (FLAT) (QXRAD)
  137.    (prompt "Find a clear space on drawing then type (dflat): ")
  138. )
  139. 
  140.